COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	(declare (fasload util fas dsk (aid rpg)))
C00008 ENDMK
C⊗;
(declare (fasload util fas dsk (aid rpg)))
(declare (mapex t) 
	 (special to-dump-junk to-dump-file dump-printer))

(setq to-dump-junk () to-dump-file () dump-printer 'print)

(macrodef macro-name (x)
 (cond ((atom (cadr x))(cadr x))
       (t (caadr x))))

(defun load-file fexpr (file)
 (apply 'eread file)
 (setq to-dump-file file)
 (select-disk-input
  (read-until-eof with form do
   (cond ((atom form)(eval form))
	 ((memq (car form) '(macro macrodef))
	  (push (cons 'macro (macro-name form)) to-dump-junk) 
	  (eval form))
	 ((eq (cadr form) 'macro)
	  (push (cons 'macro (caddr form)) to-dump-junk)
	  (eval form))
	 ((eq (caddr form) 'macro)
	  (push (cons 'macro (cadr form)) to-dump-junk)
	  (eval form))
	 ((eq (car form) 'require)
	  (terpri)(princ '|Don't handle REQUIREs yet.|)(terpri))
	 ((eq (car form) 'defun)
	  (cond ((eq (caddr form) 'fexpr)
		 (push (cons 'defun-fexpr (cadr form)) to-dump-junk))
		((atom (caddr form))
		 (push (cons 'defun-lexpr (cadr form)) to-dump-junk))
		(t (push (cons 'defun-expr (cadr form)) to-dump-junk))) 
	  (eval form))
	 ((eq (car form) 'setq)
	  (let f ← (cdr form) do
	       (while f do
		      (push (cons 'variable (car f)) to-dump-junk)
		      (set (car f) (eval (cadr f)))
		      (setq f (cddr f)))))
	 (t (eval form)))) 
  file))

(defun dump ()
 (uwrite)
 (let to-dump-junk ← (reverse to-dump-junk) do
 (unselect-tty
   (select-disk-output
    (for item ε to-dump-junk do
	 (selectq (car item)
		  (variable
		   (funcall dump-printer `(setq ,(cdr item) ',(symeval (cdr item)))))
		  (defun-expr
		   (funcall dump-printer 
		    `(defun ,(cdr item) .
			    ,(dump-make-expr (get (cdr item) 'expr)))))
		  (defun-fexpr
		   (funcall dump-printer `(defun ,(cdr item) fexpr .
				     ,(dump-make-expr (get (cdr item) 'fexpr)))))
		  (defun-lexpr
		   (funcall dump-printer `(defun ,(cdr item) .
				     ,(dump-make-expr (get (cdr item) 'expr)))))
		  (macro
		   (funcall dump-printer `(defun ,(cdr item) .
				     ,(dump-make-expr (get (cdr item) 'macro)))))
		  ())))))
 (setq to-dump-junk ())
 (cond ((probef (namelist to-dump-file))
	(deletef (namelist to-dump-file))))
 (apply 'ufile (namelist to-dump-file))  
 to-dump-file)

(defun dump-make-expr (x)
 `(,(cadr x) . ,(cddr x)))

(macrodef type (x)
(let prop ← () do
     (cond ((setq prop (get x 'expr))
	    (cond ((atom (cadr  prop))
		   'lexpr)
		  (t 'expr)))
	   ((get x 'fexpr)
	    'fexpr)
	   ((get x 'macro)
	    'macro)
	   (t 'variable)))) 

(defun to-dump fexpr (items)
 (for item ε items do
      (selectq (type item)
	       (expr
		(push (cons 'defun-expr item) to-dump-junk))
	       (fexpr
		(push (cons 'defun-fexpr item) to-dump-junk))
	       (lexpr
		(push (cons 'defun-lexpr item) to-dump-junk))
	       (variable
		(push (cons 'variable item) to-dump-junk))
	       (macro
		(push (cons 'defun-macro item) to-dump-junk))
	       ())))

(sstatus ttyint 453. 'dump-handler)
(sstatus ttyint 485. 'dump-handler)

(defun dump-handler (x y)(print (dump))(terpri))

(defun refilev fexpr (x)
 (funcall 'to-dump (cond ((atom (car x))(ncons (car x)))
			 (t (car x))))
 (setq to-dump-file (cadr x))
 (dump))